COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	DEFINE NIL='400000, LIST="INTEGER"
C00014 ENDMK
C⊗;
DEFINE NIL='400000, LIST="INTEGER";
DEFINE NILNIL=NIL+1;
DEFINE BEGINLIST=5;
OWN SAFE LIST ARRAY CAD[NIL:NIL+NLIST],
                    EVC[NIL LSH -2:(NIL+NLIST+3) LSH -2],
                    ROOT[0:NROOT];
PRELOAD_WITH '777,'777000,'777000000,'777000000000;
OWN SAFE INTEGER ARRAY EVCMASK[0:3];
PRELOAD_WITH '001,'001000,'001000000,'001000000000;
OWN SAFE INTEGER ARRAY EVCONE[0:3];

SIMPLE LIST PROCEDURE CAR(LIST EL); RETURN(CAD[EL] LSH -18);

SIMPLE LIST PROCEDURE CDR(LIST EL); RETURN(CAD[EL] LAND '777777);

SIMPLE BOOLEAN PROCEDURE NULLP(LIST EL); RETURN(EL=NIL);

SIMPLE BOOLEAN PROCEDURE LISTP(LIST EL); RETURN(EL>NIL);

SIMPLE BOOLEAN PROCEDURE ATOMP(LIST EL); RETURN(EL<NIL);

SIMPLE LIST PROCEDURE RPLACA(LIST EL, VAL);
   BEGIN
   CAD[EL]←(CAD[EL] LAND '777777) LOR (VAL LSH 18);
   RETURN(EL);
   END;

SIMPLE LIST PROCEDURE RPLACD(LIST EL, VAL);
   BEGIN
   CAD[EL]←(CAD[EL] LAND '777777000000) LOR VAL;
   RETURN(EL);
   END;

RECURSIVE PROCEDURE COLLECT(LIST NODE);
   BEGIN
   INTEGER NOS;
   WHILE LISTP(NODE)∧((EVC[NODE LSH -2]←EVC[NODE LSH -2]-EVCONE[NODE LAND '3])
                                             LAND EVCMASK[NODE LAND '3])=0  DO
      BEGIN
      NOS←NODE;
      COLLECT(CAR(NODE));
      NODE←CDR(NOS);
      CAD[NOS]←ROOT[0];
      EVC[NOS ASH -2]←
         EVCONE[NOS LAND '3]+(EVC[NOS ASH -2] LAND LNOT EVCMASK[NOS LAND '3]);
      ROOT[0]←NOS;
      END;
   END;

PROCEDURE CHKCOLLECT(LIST NODE);
comment collect an un-pointed-to structure;
IF LISTP(NODE)∧(EVC[NODE LSH -2] LAND EVCMASK[NODE LAND '3])=0  THEN
   BEGIN
   COLLECT(CAR(NODE));
   COLLECT(CDR(NODE));
   CAD[NODE]←ROOT[0];
   EVC[NODE ASH -2]←
      EVCONE[NODE LAND '3]+(EVC[NODE ASH -2] LAND LNOT EVCMASK[NODE LAND '3]);
   ROOT[0]←NODE;
   END;

SIMPLE LIST PROCEDURE CONS(LIST A,B);
   BEGIN
   LIST NODE;
   IF LISTP(A) THEN EVC[A LSH -2]←EVC[A LSH -2]+EVCONE[A LAND '3];
   IF LISTP(B) THEN EVC[B LSH -2]←EVC[B LSH -2]+EVCONE[B LAND '3];
   IF NULLP(ROOT[0]) THEN
      BEGIN
      PRINT("COLLECT ");
      FOR NODE←NIL+BEGINLIST STEP 1 UNTIL NIL+NLIST DO
      IF (EVC[NODE LSH -2] LAND EVCMASK[NODE LAND '3])=0 THEN
	 BEGIN
	 COLLECT(CAR(NODE));
	 COLLECT(CDR(NODE));
	 CAD[NODE]←ROOT[0];
	 EVC[NODE LSH -2]←
            EVCONE[NODE LAND '3]+(EVC[NODE ASH -2] LAND LNOT EVCMASK[NODE LAND '3]);
	 ROOT[0]←NODE;
	 END;
      END;
   IF NULLP(ROOT[0]) THEN
      BEGIN
      PRINT("List storage capacity exceeded",'15&'12,"Fatal termination",'15&'12);
      WHILE TRUE DO CALL(60,"SLEEP");
      END;
   NODE←ROOT[0];
   ROOT[0]←CDR(ROOT[0]);
   CAD[NODE]←(A LSH 18) LOR B;
   EVC[NODE LSH -2]←EVC[NODE LSH -2] LAND LNOT EVCMASK[NODE LAND '3];
   RETURN(NODE);
   END;

SIMPLE PROCEDURE SETQ(REFERENCE INTEGER RT; LIST LS);
   BEGIN
   IF LISTP(LS) THEN EVC[LS LSH -2]←EVC[LS LSH -2]+EVCONE[LS LAND '3];
   COLLECT(RT); RT←LS;
   END;

SIMPLE PROCEDURE DISSET(INTEGER RT);
   IF LISTP(RT) THEN EVC[RT LSH -2]←EVC[RT LSH -2]-EVCONE[RT LAND '3];

SIMPLE PROCEDURE LINIT;
   BEGIN
   LIST I;
   CAD[NIL]←NIL; EVC[NIL LSH -2]←EVCONE[NIL LAND '3]; ROOT[0]←NIL+BEGINLIST;
   FOR I←NIL+BEGINLIST STEP 1 UNTIL NIL+NLIST DO
      BEGIN
      CAD[I]←I+1;
      EVC[I LSH -2]←EVC[I LSH -2] LOR EVCONE[I LAND '3];
      END;
   CAD[NIL+NLIST]←NIL;
   FOR I←1 STEP 1 UNTIL NROOT DO ROOT[I]←NIL;
   CAD[NILNIL]←(NIL LSH 18) LOR NIL;  comment make NIL.NIL;
   EVC[NILNIL LSH -2]←EVC[NILNIL LSH -2] LOR EVCONE[NILNIL LAND '3];
      comment protect it from GC;
   END;

RECURSIVE PROCEDURE PRLIST(LIST LST);
   BEGIN

   RECURSIVE PROCEDURE CVLE(LIST LST);
      BEGIN
      WHILE LISTP(LST) DO
	 BEGIN  PRINT(" "); PRLIST(CAR(LST)); LST←CDR(LST); END;
      IF NULLP(LST) THEN PRINT(" )") ELSE PRINT(".",(LST LSH 19) ASH -19," )");
      END;

   IF NULLP(LST) THEN PRINT("()") ELSE
   IF ATOMP(LST) THEN PRINT((LST LSH 19) ASH -19)  ELSE
      BEGIN  PRINT("(");  CVLE(LST);  END;
   END;

SIMPLE INTEGER PROCEDURE LENGTHI(LIST LS);
   BEGIN
   INTEGER LN;
   LN←0;
   WHILE LISTP(LS) DO
      BEGIN
      LN←LN+1;
      LS←CDR(LS);
      END;
   RETURN(LN);
   END;

SIMPLE LIST PROCEDURE REVERSE(LIST L,TAIL(NIL));
   BEGIN
   LIST ANS;
   ANS←NIL;
   SETQ(ANS,L);
   L←NIL; SETQ(L,TAIL);
   WHILE ANS>NIL DO
      BEGIN
      SETQ(L,CONS(CAR(ANS),L));
      SETQ(ANS,CDR(ANS));
      END;
   SETQ(ANS,NIL);
   DISSET(L);
   RETURN(L);
   END;

SIMPLE LIST PROCEDURE APPEND(LIST L1,L2);
   BEGIN
   LIST ANS;
   ANS←NIL;
   SETQ(ANS,REVERSE(L1));
   L1←NIL; SETQ(L1,L2);
   WHILE ANS>NIL DO
      BEGIN
      SETQ(L1,CONS(CAR(ANS),L1));
      SETQ(ANS,CDR(ANS));
      END;
   SETQ(ANS,NIL);
   DISSET(L1);
   RETURN(L1);
   END;

SIMPLE LIST PROCEDURE LIST1(LIST A);  RETURN(CONS(A,NIL));
SIMPLE LIST PROCEDURE LIST2(LIST A,B);  RETURN(CONS(A,CONS(B,NIL)));
SIMPLE LIST PROCEDURE LIST3(LIST A,B,C);  RETURN(CONS(A,CONS(B,CONS(C,NIL))));
SIMPLE LIST PROCEDURE LIST4(LIST A,B,C,D);  RETURN(CONS(A,CONS(B,CONS(C,CONS(D,NIL)))));
SIMPLE LIST PROCEDURE LIST5(LIST A,B,C,D,E);
     RETURN(CONS(A,CONS(B,CONS(C,CONS(D,CONS(E,NIL))))));
SIMPLE LIST PROCEDURE LIST6(LIST A,B,C,D,E,F);
     RETURN(CONS(A,CONS(B,CONS(C,CONS(D,CONS(E,CONS(F,NIL)))))));
SIMPLE LIST PROCEDURE LIST7(LIST A,B,C,D,E,F,G);
     RETURN(CONS(A,CONS(B,CONS(C,CONS(D,CONS(E,CONS(F,CONS(G,NIL))))))));

SIMPLE LIST PROCEDURE CADR(LIST L); RETURN(CAR(CDR(L)));
SIMPLE LIST PROCEDURE CDDR(LIST L); RETURN(CDR(CDR(L)));
SIMPLE LIST PROCEDURE CDAR(LIST L); RETURN(CDR(CAR(L)));
SIMPLE LIST PROCEDURE CAAR(LIST L); RETURN(CAR(CAR(L)));

SIMPLE LIST PROCEDURE CAAAR(LIST L); RETURN(CAR(CAR(CAR(L))));
SIMPLE LIST PROCEDURE CAADR(LIST L); RETURN(CAR(CAR(CDR(L))));
SIMPLE LIST PROCEDURE CADAR(LIST L); RETURN(CAR(CDR(CAR(L))));
SIMPLE LIST PROCEDURE CADDR(LIST L); RETURN(CAR(CDR(CDR(L))));
SIMPLE LIST PROCEDURE CDAAR(LIST L); RETURN(CDR(CAR(CAR(L))));
SIMPLE LIST PROCEDURE CDADR(LIST L); RETURN(CDR(CAR(CDR(L))));
SIMPLE LIST PROCEDURE CDDAR(LIST L); RETURN(CDR(CDR(CAR(L))));
SIMPLE LIST PROCEDURE CDDDR(LIST L); RETURN(CDR(CDR(CDR(L))));

SIMPLE LIST PROCEDURE CAAAAR(LIST L); RETURN(CAR(CAR(CAR(CAR(L)))));
SIMPLE LIST PROCEDURE CAAAAAR(LIST L); RETURN(CAR(CAR(CAR(CAR(CAR(L))))));

SIMPLE LIST PROCEDURE CDAAAR(LIST L); RETURN(CDR(CAR(CAR(CAR(L)))));
SIMPLE LIST PROCEDURE CDAAAAR(LIST L); RETURN(CDR(CAR(CAR(CAR(CAR(L))))));

SIMPLE LIST PROCEDURE CADDDR(LIST L); RETURN(CAR(CDR(CDR(CDR(L)))));
SIMPLE LIST PROCEDURE CADDDDR(LIST L); RETURN(CAR(CDR(CDR(CDR(CDR(L))))));

SIMPLE LIST PROCEDURE CDDDDR(LIST L); RETURN(CDR(CDR(CDR(CDR(L)))));
SIMPLE LIST PROCEDURE CDDDDDR(LIST L); RETURN(CDR(CDR(CDR(CDR(CDR(L))))));

SIMPLE LIST PROCEDURE CDDDAR(LIST L); RETURN(CDR(CDR(CDR(CAR(L)))));
SIMPLE LIST PROCEDURE CDDDDAR(LIST L); RETURN(CDR(CDR(CDR(CDR(CAR(L))))));

REQUIRE LINIT INITIALIZATION;